home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / sys / m68lap.t < prev    next >
Text File  |  1988-02-05  |  10KB  |  312 lines
  1. (herald m68lap
  2.         (env tsys))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. (define local-processor
  28.   (lambda ()
  29.     (object nil
  30.       ((processor-type self)     'MC68000)
  31.       ((mc68000-processor? self) '#t)
  32.       ((print-type-string self)  "Processor"))))
  33.         
  34. ;;; lap code is of the form (lap free-vars . code)
  35. ;;; lap templates are (lap-template (pointer scratch nargs) . code)
  36.  
  37. (define (invoke-stack-continuation frame vals)
  38.   (lap (return apply)
  39.     (sub .l ($ 2) A1)
  40.     (move .l A1 SP)
  41.     (cmp .l A2 nil-reg)
  42.     (j= no-values)
  43.     (cmp .l (d@r A2 -3) nil-reg)
  44.     (jn= many-values)
  45.     (move .l (d@r A2 1) A1)
  46.     (move .l ($ -2) NARGS)
  47.     (move .l (@r sp) tp)
  48.     (jmp (@r tp))
  49. no-values
  50.     (move .l ($ -1) NARGS)
  51.     (move .l (@r sp) tp)
  52.     (jmp (@r tp))
  53. many-values
  54.     (move .l (d@static P (static 'return)) A1)
  55.     (move .l (d@static P (static 'apply)) P)
  56.     (move .l ($ 3) NARGS)
  57.     (move .l (d@r p -2) tp)
  58.     (jmp (@r tp))))
  59.  
  60. (define (invoke-continuation sp stack vals base-state current-state)
  61.   (lap (rewind-state-and-continue)
  62.     (bset ($ 6) (d@r task task/critical-count))
  63.     (move .l A1 SP)                    ; set new continuation
  64.     (move .l (d@r TASK task/stack) S0) ; limit at stack base
  65.     (add .l ($ 2) A2)                  ; start at first word of stack in heap
  66.     (jbr copy-stack-test)
  67. copy-stack-loop 
  68.     (move .l (@r+ A2) (@r+ A1))
  69. copy-stack-test
  70.     (cmp .l A1 S0)
  71.     (j>= copy-stack-loop)
  72.     (bclr ($ 6) (d@r task task/critical-count))
  73.     (move .l (d@r TASK 12) A1)
  74.     (move .l (d@r TASK 16) A2)
  75.     (move .l (d@static P (static 'rewind-state-and-continue)) P)
  76.     (move .l ($ 4) NARGS)
  77.     (move .l (d@r p -2) tp)
  78.     (jmp (@r tp))))
  79.  
  80.  
  81. ;;; (FIXNUM-HOWLONG n)
  82. ;;;   Returns the number of bits in N's binary representation.
  83. ;;;   Horrible name, after MACLISP function HAULONG.
  84.  
  85. (define (fixnum-howlong num)
  86.   (lap ()
  87.     (move .l a1 s0)
  88.     (lsr  .l ($ 2) s0)             ; S0 hold num
  89.     (move .l ($ 0) s1)             ; S1 holds result
  90.     (move .l s0 s2)                ; S2 used as scratch
  91.     (and  .l ($ #xffff8000) s2)
  92.     (j= howlong1)
  93.     (add  .w ($ 16) s1)
  94.     (swap s0)
  95. howlong1
  96.     (move .w s0 s2)
  97.     (and  .w ($ #x7f80) s2)
  98.     (j= howlong2)
  99.     (add  .w ($ 8) s1)
  100.     (asr  .l ($ 8) s0)
  101. howlong2
  102.     (move .w s0 s2)
  103.     (and  .b ($ #x78) s2)
  104.     (j= howlong3)
  105.     (add  .w ($ 4) s1)
  106.     (asr  .l ($ 4) s0)
  107. howlong3
  108.     (move .w s0 s2)
  109.     (and  .b ($ #x6) s2)
  110.     (j= howlong4)
  111.     (add  .w ($ 2) s1)
  112.     (asr  .l ($ 2) s0)
  113. howlong4
  114.     (move .w s0 s2)
  115.     (and  .b ($ #x1) s2)
  116.     (j= howlong5)
  117.     (add  .w ($ 1) s1)
  118. howlong5
  119.     (asl  .w ($ 2) s1)
  120.     (move .l s1 a1)
  121.     (move .l ($ -2) nargs)
  122.     (move .l (@r sp) tp)
  123.     (jmp (@r tp))))
  124.  
  125.  
  126.               
  127. (define (*set x y)
  128.   (lap ()  
  129.     (move .l A2 (d@r A1 2))
  130.     (tst .b (@r A1))
  131.     (j= foo-set)
  132.     (move .l A1 (d@r TASK task/extra-pointer))
  133.     (jsr (*d@nil slink/set))
  134. foo-set    
  135.     (move .l ($ -2) NARGS)
  136.     (move .l (@r SP) TP)
  137.     (jmp (@r TP))))
  138.  
  139.  
  140. (define (apply-traced-operation proc . args)
  141.   (lap (*traced-op-template*)
  142.     (move .l (d@static P (static '*traced-op-template*)) TP)
  143.     (clr .l S0)
  144.     (jbr entry)))
  145.  
  146. (define (apply proc . args)
  147.  (lap (apply-too-many-args)
  148.   (move .l ($ 1) S0)
  149. entry
  150.   (sub .l ($ 1) NARGS)                   ;; shift proc out
  151.   (move .l P (@-r SP))                   ;; save environment 
  152.   (move .l A1 (@-r SP))                  ;; first arg is proc (save it)
  153.   (cmp .l ($ 1) NARGS)                   ;; no args to proc
  154.   (j= apply-done)
  155.   (sub .l ($ 1) NARGS)
  156.   (cmp .l ($ 1) NARGS)
  157.   (jn= next1)
  158.   (move .l A2 AN)
  159.   (jbr apply-one-arg)
  160. next1
  161.   (cmp .l ($ 2) NARGS)
  162.   (jn= next2)
  163.   (move .l A2 A1)
  164.   (move .l A3 AN)
  165.   (jbr apply-two-args)
  166. next2
  167.   (cmp .l ($ 3) NARGS)
  168.   (jn= next3)
  169.   (move .l A2 A1)
  170.   (move .l A3 A2)
  171.   (move .l (d@r TASK 12) AN)           ;; first argument temp
  172.   (jbr apply-three-args)
  173. next3
  174.   (move .l A2 A1)
  175.   (move .l A3 A2)
  176.   (move .l (d@r TASK 12) A3)            ;; first argument temp
  177.   (move .l NARGS S1)
  178.   (sub .l ($ 4) S1)                     ;; S1 counts sown to 0
  179.   (lea (d@r TASK 16) P)                ;; set up P to point into rest vector
  180.                                        ;; first 3 temps reserved, 1 done already
  181.   (jbr apply-shift-test)
  182. apply-shift-loop-top
  183.   (move .l (@r P) (d@r P -4))
  184.   (sub .l ($ 1) S1)
  185.   (add .l ($ 4) P)
  186. apply-shift-test
  187.   (cmp .l ($ 0) S1)
  188.   (jn= apply-shift-loop-top)
  189.   (move .l (@r P) AN)  
  190.   (sub .l ($ 4) P)
  191.   (jbr apply-spread-loop)
  192. apply-one-arg
  193.   (cmp .l AN nil-reg)   
  194.   (j= apply-done)
  195.   (move .l (d@r AN 1) A1)                    
  196.   (add .l ($ 1) NARGS)
  197.   (move .l (d@r AN -3) AN)                   
  198. apply-two-args
  199.   (cmp .l AN nil-reg)   
  200.   (j= apply-done)
  201.   (move .l (d@r AN 1) A2)                    
  202.   (add .l ($ 1) NARGS)
  203.   (move .l (d@r AN -3) AN)                   
  204. apply-three-args
  205.   (cmp .l AN nil-reg)   
  206.   (j= apply-done)
  207.   (move .l (d@r AN 1) A3)                    
  208.   (add .l ($ 1) NARGS)
  209.   (move .l (d@r AN -3) AN)                   
  210.   (lea (d@r TASK 12) P)
  211. apply-spread-loop              
  212.   (cmp .l AN nil-reg)
  213.   (j= apply-done)
  214.   (move .l (d@r AN 1) (@r P))
  215.   (add .l ($ 1) NARGS)
  216.   (cmp .l ($ (+ *pointer-temps* 1)) NARGS)
  217.   (j> too-many)
  218.   (add .l ($ 4) P)
  219.   (move .l (d@r AN -3) AN)
  220.   (jbr apply-spread-loop)
  221. too-many
  222.   (move .l (@r+ SP) A1)                    ; procedure is argument
  223.   (move .l (@r+ SP) P)
  224.   (move .l ($ 2) NARGS)
  225.   (move .l (d@static P (static 'apply-too-many-args)) P)
  226.   (move .l (d@r p -2) tp)
  227.   (jmp (@r tp))
  228. apply-done                                
  229.   (move .l (@r+ SP) P)                     ; restore procedure
  230.   (add .w ($ 4) SP)                        ; get rid of environment
  231.   (tst .l S0)
  232.   (j= traced)
  233.   (jmp (*d@nil slink/icall))
  234. traced            
  235.   (jmp (@r TP))))
  236.  
  237.  
  238. (define (string-hash string)
  239.   ;; string in A1
  240.   (lap ()
  241.     ;; enter critical gc
  242.     (move .l (d@r A1 offset/string-text) A3);; raw string text in A3
  243.     (add .l (d@r A1 offset/string-base) A3)                              
  244.     (add .l ($ 2) A3)
  245.     (clr .l S1)                             ;; counter in S1
  246. hash                
  247.     (move .l (d@r A1 -2) S0)                ;; length in S0
  248.     (asr .l ($ 8) S0)
  249.     (clr .l S2)                             ;; hash value so far in S2
  250.     (jmp (label hash-test))
  251. hash-loop              
  252.     (rol .l ($ 1) S2)                       ;++ change to 3 later
  253.     (add .b (@r+ A3) S2)
  254. hash-test
  255.     (add .l ($ 1) S1)
  256.     (cmp .l S1 S0)  
  257.     (j>= hash-loop)
  258.     (move .l S2 S1)
  259.     (swap S1) 
  260.     (eor .l S1 S2) 
  261.     (and .l ($ #x7ffffffc) S2)              ;; positive-fixnumize
  262.     (move .l S2 A1)
  263.     ;; exit critical gc                       ;; blat bits 0,1,31
  264.     (move .l ($ -2) NARGS)
  265.     (move .l (@r sp) tp)
  266.     (jmp (@r tp))))
  267.  
  268.             
  269. ;;;  magic frame is next-state
  270. ;;;                 winder
  271. ;;;                 previous-state
  272. ;;;                 unwinder
  273. ;;;                 *magic-frame-template*
  274.  
  275. (define (push-magic-frame unwinder stuff wind)   
  276.  (lap (*magic-frame-template* bind-internal)
  277.   (move .l (d@r TASK task/dynamic-state) AN)
  278.   (move .l nil-reg (@-r SP))                           ; next state
  279.   (move .l A3 (@-r SP))                                ; winder
  280.   (move .l AN (@-r SP))                                ; previous state
  281.   (move .l A1 (@-r SP))                                ; unwinder
  282.   (move .l (d@static P (static '*magic-frame-template*)) (@-r SP))
  283.   (lea (d@r SP 2) A1)                     ; first arg is the magic frame
  284.   (cmp .l AN nil-reg)                     ; is there a previous state?
  285.   (j= magic-frame-exit)
  286.   (move .l A1 (d@r AN 14))                ; set next slot to this magic frame
  287. magic-frame-exit
  288.   (move .l (d@static P (static 'bind-internal)) P)   ; second arg is stuff
  289.   (move .l ($ 3) NARGS)
  290.   (move .l (d@r P -2) tp)
  291.   (jmp (@r tp))))
  292.  
  293. (define (make-structure-template size)
  294.   (lap (*structure-template* *stype-template*)
  295.     (move .l (d@static P (static '*stype-template*)) AN)
  296.     (move .l ($ 36) S1)                            ; 9 slots
  297.     (jsr (*d@nil slink/make-extend))
  298.     (move .w ($ 32) (d@r AN 28))                     ; offset within closure
  299.     (move .b ($ 0) (d@r AN 27))                     ; 0 scratch slots
  300.     (move .l A1 S0)
  301.     (asr .l ($ 2) S0)                              ; pointer slots
  302.     (move .b S0 (d@r AN 26))               
  303.     (move .w ($ #x8000) (d@r AN 30))                ; high bit for template, 0 args
  304.     (move .w ($ M68-JUMP-ABSOLUTE) (d@r AN 32))
  305.     (move .l (d@static P (static '*structure-template*)) (d@r AN 34)) ; auxilliary
  306.     (lea (d@r AN 32) A1)                           ; template
  307.     (move .l AN A2)                                ; stype
  308.     (move .l ($ -3) NARGS)                         ; return two values
  309.     (move .l (@r sp) tp)
  310.     (jmp (@r tp))))
  311.  
  312.